Visual Basic 5 Developer's Kit/vb5 dev kit.iso/dev/desaware/stgtools/stg_demo/cfbrowsr.frm

Visual Basic Form | 1996-03-24 | 15.7 KB | 423 lines

VERSION 4.00
Begin VB.Form BaseForm
   BorderStyle     =   0  'None
   Caption         =   "Structured Storage Browser"
   ClientHeight    =   3495
   ClientLeft      =   1065
   ClientTop       =   1680
   ClientWidth     =   5775
   Height          =   4185
   Icon            =   "CFBROWSR.frx":0000
   Left            =   1005
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   3495
   ScaleWidth      =   5775
   Top             =   1050
   Width           =   5895
   Begin VB.CommandButton Command1
      Caption         =   "View Contents"
      Enabled         =   0   'False
      Height          =   495
      Left            =   2760
      TabIndex        =   1
      Top             =   2880
      Width           =   2895
   End
   Begin DwstgLibDemo.DwStorage DwStorage1
      Left            =   2760
      Top             =   2160
      _Version        =   65536
      _ExtentX        =   741
      _ExtentY        =   741
      _StockProps     =   0
   End
   Begin VB.Label AboutText
      BackStyle       =   0  'Transparent
      Height          =   2295
      Left            =   2760
      TabIndex        =   4
      Top             =   600
      Width           =   3015
   End
   Begin MSOutl.Outline FilesList
      Height          =   3015
      Left            =   120
      TabIndex        =   0
      Top             =   360
      Width           =   2535
      _Version        =   65536
      _ExtentX        =   4471
      _ExtentY        =   5318
      _StockProps     =   77
      MouseIcon       =   "CFBROWSR.frx":030A
      Style           =   5
      PicturePlus     =   "CFBROWSR.frx":0326
      PictureMinus    =   "CFBROWSR.frx":0498
      PictureLeaf     =   "CFBROWSR.frx":060A
      PictureOpen     =   "CFBROWSR.frx":077C
      PictureClosed   =   "CFBROWSR.frx":08EE
   End
   Begin VB.Label AboutFile
      BackStyle       =   0  'Transparent
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   2760
      TabIndex        =   3
      Top             =   360
      Width           =   3015
   End
   Begin VB.Label Directory
      BackStyle       =   0  'Transparent
      Height          =   255
      Left            =   120
      TabIndex        =   2
      Top             =   120
      Width           =   5655
   End
   Begin VB.Menu menuFile
      Caption         =   "&File"
      Begin VB.Menu menuLoad
         Caption         =   "&Load Compound File..."
      End
      Begin VB.Menu FatAlbert
         Caption         =   "-"
      End
      Begin VB.Menu menuExit
         Caption         =   "&Exit"
      End
   End
   Begin VB.Menu menuHelp
      Caption         =   "&Help"
      Begin VB.Menu menuOther
         Caption         =   "&Other Desaware Products..."
      End
      Begin VB.Menu menuRudy
         Caption         =   "-"
      End
      Begin VB.Menu menuAbout
         Caption         =   "&About StorageBrowser..."
      End
   End
Attribute VB_Name = "BaseForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim ParentStorage As Object ' contains the parent of the currently open stream or storage
Dim TempStorage As Object
Dim TempStream As Object
Dim EOL As String * 2 ' line feed and carriage return
Dim RootExists As Boolean ' True if a storage is currently open
Dim ReadOnly As Boolean   ' True if the currently open storage is read only
' These are for use by the File Open and Save common dialogs.
Const vbOFNHideReadOnly = &H4&
Const vbOFNFileMustExist = &H1000&
' This correctly shows the sub-elements of an item that
' was expanded.
Private Sub DoExpand(ListIndex As Integer)
    Dim i As Integer
    Dim newIndent As Integer
    ' Only read the elements in a storage once, in order
    ' to reduce disk access and improve speed.
    If (FilesList.HasSubItems(ListIndex) = False) Then
        BaseForm.MousePointer = 11
        newIndent = FilesList.Indent(ListIndex) + 1
        ReadChildren FilesList.FullPath(ListIndex), ListIndex + 1, newIndent
        BaseForm.MousePointer = 0
    End If
    FilesList.Expand(ListIndex) = True
End Sub
' Reads the elements in a specific storage and enters
' them into the outline listbox.
Public Sub ReadChildren(storage As String, ListIndex As Integer, level As Integer)
    Dim i As Integer
    Dim text As String
    Dim FileType As Integer
On Error GoTo badStorage
    Set TempStorage = GlobalRootStorage.OpenStorage(storage, STG_READ Or STG_TRANSACTED Or STG_SHARE_EXCLUSIVE)
    i = 0
    Do
        text = TempStorage.Directory(i, FileType)
        If FileType = STG_TYPE_NONE Then Exit Do
        FilesList.AddItem (text), (ListIndex + i)
        FilesList.Indent(ListIndex + i) = level
        FilesList.ItemData(ListIndex + i) = FileType
        If FileType = STG_TYPE_STORAGE Then
            FilesList.PictureType(ListIndex + i) = outClosed
        ElseIf FileType = STG_TYPE_STREAM Then
            FilesList.PictureType(ListIndex + i) = outLeaf
        End If
        i = i + 1
    Loop
    Set TempStorage = Nothing
    ListIndex = ListIndex - 1
    Exit Sub
badStorage:
    MsgBox "Error while searching storage:" & Chr$(13) & Err.Description
    Exit Sub
End Sub
' This brings up a window that allows the user to view the contents
' of a stream.
Private Sub Command1_Click()
    Dim path As String
    Dim pathLength As Integer
    ' Make sure something is selected.
    If FilesList.ListIndex = -1 Then Exit Sub
    ' Make sure the selected element is a stream.
    If FilesList.ItemData(FilesList.ListIndex) = STG_TYPE_STREAM Then
        ' Treat Summary Info Property Sets differently
        If (FilesList.List(FilesList.ListIndex) = (Chr$(5) & "SummaryInformation")) Then
            If (RootExists = False) Then Exit Sub
            SIView.Show
            Exit Sub
        End If
        ' Get the data
        path = FilesList.FullPath(FilesList.ListIndex)
        pathLength = Len(path) - Len(FilesList.List(FilesList.ListIndex))
        If (pathLength > 0) Then
            path = Left(path, pathLength - 1)
            Set TempStorage = GlobalRootStorage.OpenStorage(path, STG_READ Or STG_DIRECT Or STG_SHARE_EXCLUSIVE)
            Set TempStream = TempStorage.OpenStream(FilesList.List(FilesList.ListIndex), STG_READ Or STG_DIRECT Or STG_SHARE_EXCLUSIVE)
        Else
            Set TempStream = GlobalRootStorage.OpenStream(FilesList.List(FilesList.ListIndex), STG_READ Or STG_DIRECT Or STG_SHARE_EXCLUSIVE)
        End If
        GlobalSize = TempStream.GetSize()
#If Win16 Then
        If (GlobalSize > 65400) Then ' not 65536 to give it room for overhead
            GlobalSize = 65400
        End If
#End If
        GlobalText = String(GlobalSize, 0)
        ' Get the information in the stream into a variable BinaryEdit can use.
        TempStream.Get 0, GlobalText
        BinaryEdit.Show
        ' Always set the objects to nothing when you are done!
        Set TempStorage = Nothing
        Set TempStream = Nothing
    End If
End Sub
' Respond when the user clicks in the outline listbox.
Private Sub FilesList_Click()
    Dim name As String
    Dim special As Integer
    Dim FullText As String
    Dim StorageDate As Date
    Dim size As Long
    Dim path As String
    Dim pathLength As Integer
    If FilesList.ListCount = 0 Then Exit Sub
    ' enable the menu items that depend on an element
    ' being selected
    Command1.Enabled = True
    AboutText.Caption = ""
    ' get rid of special first char, but remember it
    name = FilesList.List(FilesList.ListIndex)
    If Asc(Mid(name, 1, 1)) < 32 Then
        special = Asc(Mid(name, 1, 1))
        name = Right$(name, Len(name) - 1)
    End If
    ' Put descriptive information into the labels.
    AboutFile.Caption = name
    FullText = "full path:" & EOL
    path = FilesList.FullPath(FilesList.ListIndex)
    pathLength = Len(path) - Len(FilesList.List(FilesList.ListIndex))
    If pathLength = 0 Then
        path = ""
    Else
        path = Left(path, pathLength - 1)
    End If
    FullText = FullText & "\" & path & EOL
    Select Case special
        Case 1, 2
            FullText = FullText & "Reserved for use by the OLE libraries" & EOL
        Case 3
            FullText = FullText & "Reserved for use by the container of the OLE object which owns this file." & EOL
        Case 4
            FullText = FullText & "Reserved for use by the Structured Storage implementation." & EOL
        Case 5
            FullText = FullText & "Reserved as a publicly available description of this file." & EOL
        Case 6 To 31
            FullText = FullText & "Reserved by an unknown agent" & EOL
        'case else is a normal element
    End Select
    FullText = FullText & EOL
    If (FilesList.ItemData(FilesList.ListIndex) = 1) Then
        FullText = FullText & "this is a Storage" & EOL
        Set TempStorage = GlobalRootStorage.OpenStorage(FilesList.FullPath(FilesList.ListIndex), STG_READ Or STG_DIRECT Or STG_SHARE_EXCLUSIVE)
        StorageDate = TempStorage.GetCreationDate()
        FullText = FullText & "created : " & EOL & "   " & StorageDate & EOL
        StorageDate = TempStorage.GetLastModifyDate()
        FullText = FullText & "last Modified : " & EOL & "   " & StorageDate & EOL
        StorageDate = TempStorage.GetLastAccessDate()
        If StorageDate <> 0 Then
            FullText = FullText & "last Access : " & EOL & "   " & StorageDate & EOL
        End If
        Set TempStorage = Nothing
    Else
        FullText = FullText & "this is a Stream" & EOL
        If (pathLength > 0) Then
            Set TempStorage = GlobalRootStorage.OpenStorage(path, STG_READ Or STG_DIRECT Or STG_SHARE_EXCLUSIVE)
            Set TempStream = TempStorage.OpenStream(FilesList.List(FilesList.ListIndex), STG_READ Or STG_DIRECT Or STG_SHARE_EXCLUSIVE)
        Else
            Set TempStream = GlobalRootStorage.OpenStream(FilesList.List(FilesList.ListIndex), STG_READ Or STG_DIRECT Or STG_SHARE_EXCLUSIVE)
        End If
        size = TempStream.GetSize()
        FullText = FullText & "size : " & size & " bytes" & EOL
        Set TempStream = Nothing
        Set TempStorage = Nothing
    End If
    AboutText.Caption = FullText
End Sub
Private Sub FilesList_Collapse(ListIndex As Integer)
    Dim i As Integer
    i = 1
    If (FilesList.HasSubItems(ListIndex) = True) Then
        Do While (FilesList.Indent(ListIndex + i) > FilesList.Indent(ListIndex))
            If FilesList.PictureType(ListIndex + i) = outOpen Then
                FilesList.PictureType(ListIndex + i) = outClosed
            End If
            i = i + 1
            If ((ListIndex + i) >= FilesList.ListCount) Then Exit Do
        Loop
    Else
        If FilesList.PictureType(ListIndex + i) = outOpen Then
            FilesList.PictureType(ListIndex + i) = outClosed
        End If
    End If
End Sub
' Expand or collapse the tree.
Private Sub FilesList_DblClick()
    If FilesList.PictureType(FilesList.ListIndex) = outLeaf Then Exit Sub
    If FilesList.Expand(FilesList.ListIndex) Then
        FilesList.PictureType(FilesList.ListIndex) = outClosed
        FilesList.Expand(FilesList.ListIndex) = False
    Else
        FilesList.PictureType(FilesList.ListIndex) = outOpen
        DoExpand (FilesList.ListIndex)
    End If
End Sub
Private Sub FilesList_PictureClick(ListIndex As Integer)
    If FilesList.ListIndex = -1 Then Exit Sub
    If FilesList.PictureType(FilesList.ListIndex) = outLeaf Then Exit Sub
    If FilesList.Expand(FilesList.ListIndex) Then
        FilesList.PictureType(FilesList.ListIndex) = outClosed
        FilesList.Expand(FilesList.ListIndex) = False
    Else
        FilesList.PictureType(FilesList.ListIndex) = outOpen
        DoExpand (FilesList.ListIndex)
    End If
End Sub
' Set up some global variables and values.
Private Sub Form_Load()
    Set GlobalRootStorage = Nothing
    Set TempStream = Nothing
    Set TempStorage = Nothing
    RootExists = False ' I have not yet loaded a storage file.
    Command1.Enabled = False
    EOL = Chr$(13) & Chr$(10)
End Sub
' Clear the objects, destroying the objects they used to contain.
Private Sub Form_Unload(Cancel As Integer)
    Set GlobalRootStorage = Nothing
    Set TempStream = Nothing
    Set TempStorage = Nothing
    'Unload BaseForm
End Sub
' Bring up the About box
Private Sub menuAbout_Click()
    Load About
    About.Show
End Sub
' Cleans up and exits the program.
Private Sub menuExit_Click()
    If RootExists And (ReadOnly = False) Then
        GlobalRootStorage.Revert
    End If
    Unload BaseForm
    End
End Sub
' Brings up the Load File common dialog box and opens the file specified.
Private Sub menuLoad_Click()
    Dim file As String
    Dim i As Integer
    Dim text As String
    Dim FileType As Integer
    Dim RetVal As Integer
    Set TempStream = Nothing
    Set TempStorage = Nothing
    file = App.path & "\test.stg"
    If DwStorage1.IsStorageFile(file) = False Then
        MsgBox "The test file is probably corrupt."
        Exit Sub
    Else
        If RootExists Then GlobalRootStorage.Revert
        Set GlobalRootStorage = Nothing
        FilesList.Clear
        On Error GoTo loadProblem2
        Set GlobalRootStorage = DwStorage1.OpenStorageFile(file, STG_READWRITE Or STG_TRANSACTED Or STG_SHARE_EXCLUSIVE)
        On Error GoTo 0
        ReadOnly = False
        RootExists = True
    End If
    Directory = file
readDirectory: ' this reads the directory of the root storage
    AboutFile.Caption = ""
    AboutText.Caption = ""
    i = 0
    Do
        text = GlobalRootStorage.Directory(i, FileType)
        ' This code would delete the special character
        ' if it exists, so you don't get that block in
        ' front of the name.
        'If Asc(Mid(text, 1, 1)) < 32 Then
        '    text = Right$(text, Len(text) - 1)
        'End If
        If FileType = STG_TYPE_NONE Then Exit Do
        FilesList.AddItem text
        FilesList.ItemData(i) = FileType
        If FileType = STG_TYPE_STORAGE Then
            FilesList.PictureType(i) = outClosed
        ElseIf FileType = STG_TYPE_STREAM Then
            FilesList.PictureType(i) = outLeaf
        End If
        i = i + 1
    Loop
    If i = 0 Then MsgBox "This storage is empty."
Exit Sub
loadProblem1:
    On Error GoTo notJustReadOnly
    If Err.Number = STG_E_ACCESSDENIED Then
        Set GlobalRootStorage = DwStorage1.CreateStorageFile(file, STG_CONVERT Or STG_READ Or STG_TRANSACTED Or STG_SHARE_EXCLUSIVE)
        ReadOnly = True
        Resume readDirectory
    Else
        MsgBox "Error durring load:" & Chr$(13) & Err.Description & ",," & Err.Number
        RootExists = False
        Exit Sub
    End If
loadProblem2:
    If Err.Number = STG_E_ACCESSDENIED Then 'read only
        On Error GoTo notJustReadOnly
        Set GlobalRootStorage = DwStorage1.OpenStorageFile(file, STG_READ Or STG_DIRECT Or STG_SHARE_EXCLUSIVE)
        ReadOnly = True
        Resume readDirectory
    Else
notJustReadOnly:
        MsgBox "Error durring load: " & Chr$(13) & Err.Description & "," & Err.Number
        RootExists = False
        Exit Sub
    End If
End Sub
Private Sub menuOther_Click()
    Load sdother
    sdother.Show
End Sub